perm filename PTMOVX.F4[MSS,LCS]7 blob
sn#199898 filedate 1976-01-29 generic text, type T, neo UTF8
00100 C****** PTMOVE.F4
00200 SUBROUTINE PTMOVE(RN,PWDS)
00300 IMPLICIT INTEGER(A-Q,S-Z)
00400 DIMENSION R(2,400),IR(2,400),RN(1),PWDS(1)
00450 COMMON/KNR/KR(400) /NNP/NP(400)
00500 REAL POS,EXTEN,PRCNT,ACCX
00600 COMMON/STF/RSTFAC(-3/4),RSTJ2
00700 COMMON /KJY/ KY,JY
00800 COMMON R2,JA,CENTR,J2,RJQ(18),RNO,JR,LX,RDIS
00900 COMMON/POSI/STFF(-3/4),JJ2,POS/LLL/ITEM,LL,I,IX
01200 EQUIVALENCE (R5,RJQ(3)),(R7,RJQ(5)),(R4,RJQ(2))
01300 1,(R3,RJQ(1)),(R8,RJQ(6)),(R9,RJQ(7))
01400 1,(IR,R)
01500 DATA RSP/.5/,RI/4.5/
01600
01700 JJ2=-1
01800 J2=0
02000 C 99=BACKUP
02600 IF(LL.EQ.'J')GO TO 12
02700 RDIS=0
05575 CCC66 NST=1
05800 JJ=0
05900 IF(R4.NE.R8.OR.R5.NE.R9)JJ=-1
05950 JY=0
05960 C JY IS CHANGED IN GETPTS
06000 IF(JJ)CALL GETPTS(LX,RN,PWDS)
06220 IF(JY.EQ.0)RETURN
06300 CALL MOVIT(RN)
06400 RETURN
06660 12 IF(R4.EQ.0)R4=.001
06670 CCC IF(R5.EQ.0)R5=200
06680 RCNT=0
06700 RRT=R5
06800 RZRO=R4
07200 RJSZ=RI
07300 CALL GETPTS(LX,RN,PWDS)
07350 IF(JY.EQ.0)RETURN
07400 ROV=RRT
07500 PRCNT=1.
07600 R7=R2
07900 19 IF(RCNT.GT.9)GO TO 101
08000 RJSZ=RJSZ-.06
08100 RP=PRCNT
08200 RCNT=RCNT+1
08500
08600 CCC DO 11 KN=-3,4
08650 KN=R2
08700 RSPC=0
08800 CCC R8=KN
08900 N=0
09000
09050 RBB=-100
09100 DO 2 K=1,KY+1
09150 C WAS -1 ABOVE BECAUSE GETPTS GOES TOO FAR
09200 L=NP(K)
09300 RL=RN(L)
09365 RA=RN(L+1)
09430 RB=RN(L+3)
09435 IF(RB.LT.RBB)GO TO 280
09440 RBB=RB
09495 CCC IF(RN(L+2).EQ.R8)GO TO 77
09560 C THIS STAFF?
09625 CCC IF(RA.NE.4)GO TO 2
09690 C SKIPS HOMED NOTES (IN CHORDS)
09755 CC77 IF(RA.EQ.1)GO TO 10
09820 CC27 IF(RA.LE.4)GO TO 177
09885 77 IF(RA.LT.3)GO TO 10
09950 IF(RA.EQ.4)GO TO 444
10015 IF(RA.EQ.3)GO TO 333
10080 C LOOKS AT NOTES,RESTS,CLEFS,BAR LINES,KSIGS,METERS.
10145 IF(RA.LT.17)GO TO 2
10210 GO TO 10
10275 333 IF(RL.LT.3)GO TO 10
10340 C <3 MEANS NOTHING IN P5
10405 IF(AMOD(RN(L+5),100.0).GT.3)GO TO 2
10470 C NOT A REAL CLEF IF >3
10535 GO TO 10
10600 444 IF(RL.GT.2)GO TO 2
10665 C SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
10730 10 N=N+1
10800 R(1,N)=RB
10900 IR(2,N)=L
11000 IF(N.EQ.200)GO TO 28
11100 C ONLY TREATS 200 ITEMS AT A TIME.
11200 2 CONTINUE
11300
11400 280 IF(N.EQ.0)GO TO 11
11500 28 DO 23 K=1,N
11600 23 IF(RN(IR(2,K)+1).NE.4)GO TO 24
11700 C SKIPS IF ONLY BAR LINES ON THIS STAFF
11800 GO TO 11
11900 24 RSZ=RSTJ2*PRCNT
12000 CC ALREADY SORTED IN 'PARTS'. CALL SORT2(R,N)
12100
12200 C JUMP IF LAST IS A BAR LINE.
12300 K=0
12400 JLDGR=0
12500 JX=0
12600 22 K=K+1
12700 122 L=IR(2,K)
12800 RA=RN(L+1)
12900 RB=0
13000 RX=RN(L+5)
13100 C RX=PARAM 5
13200 RX6=RN(L+6)
13300 RY=1
13400 RW=AMOD(RN(L+4),100.)
13500 IF(RA.GT.1)GO TO 4
13600 RZ=RN(L+7)
13700 IF(LDGR.NE.JLDGR)JLDGR=0
13800 LDGR=0
13900 JK=K
14000 DO 32 JJ=JK+1,N+1
14100 K=JJ
14110 RB=R(1,JJ)-R(1,JJ-1)
14120 IF(RB.GT.0.1)GO TO 320
14130 C PUTS THEM AT EXACT SAME POINT IF CLOSER THAN .1
14140 R(1,JJ)=R(1,JJ-1)
14150 GO TO 32
14160 320 IF(RB.GT.RSP)GO TO 35
14170 32 CONTINUE
14200 CC32 IF(R(1,JJ)-R(1,JJ-1).GT.RSP)GO TO 35
14300 C FOUND HOW MANY MEMBERS TO CHORD.
14400 35 RB=0
14500 K=K-1
14600 RQ=0
14700 RD=0
14800 125 IF(AMOD(RN(L+4),200.).GT.60.)RY=.6
14900 DO 37 JJ=JK,K-1
15000 IF(RD.NE.0)GO TO 38
15100 C FINDS ONLY HIGH OR! LOW LED. LINE.
15200 JR=IR(2,JJ)
15300 RW=AMOD(RN(JR+4),100.)
15400 IF(RW.GT.12)GO TO 277
15500 IF(RW.GE.2)GO TO 38
15600 277 LDGR=-1
15700 IF(RW.GT.11)LDGR=1
15800 IF(JLDGR.EQ.LDGR)GO TO 36
15900 JLDGR=LDGR
16000 C LDGR IS FOR LEDGER LINES.
16100 GO TO 38
16200 36 RD=1.5
16300 RQ=RD
16400 38 IF(RB.GT.2)GO TO 222
16500 C JUMP IF LARGE SPACE AFTER NOTE IS ALREADY SET UP.
16600 RZZ=RN(JR+7)
16700 RE=RN(JR+5)
17000 IF(RB.GE.2)GO TO 477
17100 IF(RZZ.GE.10)GO TO 377
17200 IF(RE.GE.20)GO TO 477
17300 IF(AMOD(RZZ,10.).EQ.0)GO TO 477
17400 377 RB=1.5+EXTEN(RZZ)
17500 C SPACE FOR DOT OR TAIL(IF STEM UP)
17600 477 IF(ABS(RN(JR+6)).EQ.10)RB=RB+2
17700 C FOR CHORD TONES ON RIGHT OF STEM UP.
17800 C LOOKS THROUGH ALL NOTES OF A CHORD.
17900 222 IF(AMOD(RE,10.).EQ.0)GO TO 37
18000 C JUMP IF NO ACCIS.
18100 425 RD=2*RY+EXTEN(RE)
18200 IF(RQ.GT.RD)RD=RQ
18300 RQ=RD
18400 C FUNCT. EXTEN=AMOD(X,1.)*10.
18500 37 CONTINUE
18502 IF(RY.NE.1)RB=RB-.5*RJSZ
18503 C MINI NOTES NEED LESS SPACE
18505 250 ACCX=0
18509 RC=0
18513 RW=R(1,JX+1)
18517 DO 132 JJ=JX+1,N
18521 IF(RW.NE.R(1,JJ))GO TO 25
18525 KX=IR(2,JJ)
18529 C GET POINTER
18533 IF(RN(KX+1).NE.1)GO TO 25
18537 C ONLY CHECK ON NOTES (THIS IS FOR CHRD NOTES WITH ACCIS)
18541 IF(ABS(RN(KX+6)).GE.20)RC=2.6
18545 RE=AMOD(RN(KX+5),10.0)
18549 C FIND AN ACCI
18553 IF(RE.EQ.0)GO TO 132
18557 IF(RE.GE.1)RC=RC+2
18561 C FOUND AN ACCI
18565 RC=AMOD(RE,1.0)*10.0+RC
18569 C ADD ANY EXTENSION TO THE LEFT
18573 IF(RC.GT.ACCX)ACCX=RC
18577 RC=0
18581 IF(ACCX.GT.RD)RD=ACCX
18585 132 CONTINUE
18800 25 IF(JX.GT.0)R(2,JX)=R(2,JX)+RD*RSZ
18900 GO TO 17
19010 4 IF(RA.NE.2)GO TO 33
19028 C NEXT FOR DOTTED RESTS - IN P6
19046 IF(RN(L).GE.4)RB=RN(L+6)*1.5
19064 GO TO 250
19082 33 IF(RA.NE.3)GO TO 29
19100 RB=3
19200 IF(RX.GT.100)RB=1.5
19300 C CHECK ON SIZE NEEDED FOR CLEFS
19400 29 IF(RA.NE.4)GO TO 26
19500 RB=-RJSZ/2
19600 RD=.9
19700 GO TO 25
19800 26 IF(RA.NE.18)GO TO 30
19900 IF(RX6.GT.9)GO TO 31
20000 IF(RX.GT.9)GO TO 31
20100 C CHECKS FOR 2-DIGIT METERS
20200 RB=-1
20300 RD=1
20400 GO TO 25
20500 31 RB=2
20600 RD=3
20700 GO TO 25
20800 30 IF(RA.NE.17)GO TO 17
20900 RB=2*(ABS(RX)-1)-2
21000 C SPACES FOR CORRECT NUM OF ACCIS. RX=NUM OF ACCIS.
21100 RD=2
21200 GO TO 25
21300 17 RC=(RB+RJSZ)*RSZ
21400 C RJSZ=DEFAULT SIZE
21550 JX=K
21551 C ↑↑↑↑↑ TO RESET AFTER CHORD NOTES 12/75
21600 R(2,JX)=RC
21800 3 IF(K.LT.N)GO TO 22
21900 RA=R(1,1)
22000 RB=R(2,1)
22100
22200 DO 13 KX=2,JX
22300 RE=R(1,KX)
22400 C POS. BEFORE SHIFTING
22500 IF(ABS(RE-RA).GT..5)GO TO 14
22600 IF(R(2,KX).GT.RB)GO TO 16
22700 C SKIPS DOUBLE STOPS AND VERY CLOSE ITEMS
22800 GO TO 13
22900 C JUMP WHEN SPACE TO ADD IS SMALLER THAN WHAT'S ALREADY THERE
23000 14 RD=RA+RB-RE
23100 IF(RD.LE.0)GO TO 16
23200 C THERE'S ENOUGH ROOM
23250 ROV=ROV+RD
24000 140 R4=RE+RSPC-.001
24100 R5=10000
24200 R8=RD
24300 R9=0
24600 C GO EXPAND IT
24700 IF(R(2,KX).EQ.0)GO TO 15
24710 CALL MOVIT(RN)
24720 IF(R2.LE.4)GO TO 15
24725 R5=R4
24731 R4=RA+.001+RSPC
24753 R8=R4
24764 R9=R5+RD-.001
24770 C FOR ITEMS ON OTHER LINES.
24775 CALL MOVIT(RN)
24780 15 RSPC=RSPC+RD
24790 C RSPC SAVES TOTAL SPACE ADDED
24800 16 RB=R(2,KX)
24900 13 RA=RE
25000 11 CONTINUE
25100 110 IF(ROV.LE.RRT+.01)RETURN
25200 IF(RJSZ.GT.4)RJSZ=4
25300 PRCNT=(ROV-RZRO)/(RRT-RZRO)
25500 IF(PRCNT.NE.RP)GO TO 19
25600 C GO BACK AND EXPAND SOME MORE
25700 101 R4=RZRO
25800 R5=ROV
25900 R8=RZRO
26000 R9=RRT-.001
26100 C JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
26300 CALL MOVIT(RN)
27500 C RVX SHOULD BE FARTHEST POINT TO RIGHT.
27850 END